home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / weyl / weyl_lsp.lha / domain-support.lisp < prev    next >
Text File  |  1991-10-02  |  11KB  |  318 lines
  1. ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2. ;;; ===========================================================================
  3. ;;;                  Domains
  4. ;;; ===========================================================================
  5. ;;; (c) Copyright 1989, 1991 Cornell University
  6.  
  7. ;;; $Id: domain-support.lisp,v 2.13 1991/10/02 17:46:30 rz Exp $
  8.  
  9. (in-package "WEYLI")
  10.  
  11. (defclass domain ()
  12.   ((operation-table :initform (make-hash-table))))
  13.  
  14. (defmethod print-object ((d domain) stream)
  15.   (format stream "#<Domain: ~A>" (class-name (class-of d))))
  16.  
  17. ;; This is so that you can pretty print objects in lucid.  It appears,
  18. ;; that you are not supposed to use PRINC inside these methods.
  19. #+Lucid
  20. (defmethod print-object :around ((object domain) stream)
  21.   (let ((*print-pretty* nil))
  22.     (call-next-method object stream)))
  23.  
  24. (defmacro define-operations (domain &body operations)
  25.   `(defmethod parse-operations :after ((d ,domain))
  26.      (parse-operation-list d ',operations)))
  27.  
  28. (defmethod parse-operation-list ((d domain) operation-list)
  29.   (with-slots (operation-table) d
  30.     (loop for ((operation . arguments) nil values) on operation-list by #'cdddr
  31.       do (setf (gethash operation operation-table)
  32.            (list operation arguments values)))))
  33.  
  34. ;; Need a dummy primary method to hang all the :after methods on.
  35. (defmethod parse-operations ((d domain))
  36.   nil)
  37.  
  38. (defmethod initialize-instance :after ((d domain) &rest plist)
  39.   (declare (ignore plist))
  40.   (parse-operations d))
  41.  
  42. (defmethod list-operations ((d domain))
  43.   (with-slots (operation-table) d
  44.     (let (ops)
  45.       (maphash (lambda (key value)
  46.          (declare (ignore value))
  47.          (push key ops))
  48.            operation-table)
  49.       ops)))
  50.  
  51. (defmethod operation-arguments ((d domain) operation)
  52.   (with-slots (operation-table) d
  53.     (subst (class-name (class-of d)) 'self
  54.        (second (gethash operation operation-table)))))
  55.  
  56. (defmethod operation-values ((d domain) operation)
  57.   (with-slots (operation-table) d
  58.     (subst (class-name (class-of d)) 'self
  59.        (third (gethash operation operation-table)))))
  60.  
  61. #+Genera
  62. (defmethod describe-operations ((d domain) &optional no-complaints)
  63.   (declare (ignore no-complaints))
  64.   (let* ((class-name (class-name (class-of d)))
  65.      (domain-element (cond ((null (rest (get class-name 'domain-elements)))
  66.                 (first (get class-name 'domain-elements)))
  67.                    (t (format nil "~A element" class-name)))))
  68.     (labels ((canonicalize-class (name)
  69.            (cond ((eql name 'self) class-name)
  70.              ((atom name) name)
  71.              ((equal name '(element self))
  72.               domain-element)
  73.              (t (mapcar #'canonicalize-class name)))))
  74.       (format t "~&~S is a ~A~%" d class-name)
  75.       (fresh-line)
  76.       (with-slots (operation-table) d
  77.     (scl:formatting-table ()
  78.       (scl:with-character-style ('(nil :italic nil))
  79.         (scl:formatting-row ()
  80.           (scl:formatting-cell ()
  81.         (princ "Operation"))
  82.           (scl:formatting-cell ()
  83.         (princ "Arguments"))
  84.           (scl:formatting-cell ()
  85.         (princ "Values"))))
  86.       (maphash (lambda (key value)
  87.              (declare (ignore key))
  88.              (scl:formatting-row ()
  89.                (scl:formatting-cell ()
  90.              (princ (first value)))
  91.                (scl:formatting-cell ()
  92.              (format t "~A~{, ~A~}"
  93.                  (canonicalize-class (first (second value)))
  94.                  (mapcar #'canonicalize-class
  95.                      (rest (second value)))))
  96.                (scl:formatting-cell ()
  97.              (princ (canonicalize-class (third value))))))
  98.            operation-table))))))
  99.  
  100. #-Genera
  101. (defmethod describe-operations ((d domain) &optional no-complaints)
  102.   (declare (ignore no-complaints))
  103.   (let* ((class-name (class-name (class-of d)))
  104.      (element-classes (get class-name 'element-classes))
  105.      (domain-element (cond ((and element-classes
  106.                      (null (rest element-classes)))
  107.                 (first element-classes))
  108.                    (t (format nil "~A element" class-name)))))
  109.     (labels ((canonicalize-class (name)
  110.            (cond ((eql name 'self) class-name)
  111.              ((atom name) name)
  112.              ((equal name '(element self))
  113.               domain-element)
  114.              (t (mapcar #'canonicalize-class name)))))
  115.       (format t "~&~S is a ~A~%" d class-name)
  116.       (fresh-line)
  117.       (with-slots (operation-table) d
  118.     (format t "Operation Arguments Values")
  119.     (maphash (lambda (key value)
  120.            (declare (ignore key))
  121.            (format t "~&(~A ~A~{, ~A~}) -> ~A~%"
  122.                (first value)
  123.                (canonicalize-class (first (second value)))
  124.                (mapcar #'canonicalize-class
  125.                    (rest (second value)))
  126.                (canonicalize-class (third value))))
  127.          operation-table)))))
  128.  
  129. (defmethod required-operations ((d domain) &optional fun)
  130.   (let* ((class-name (class-name (class-of d)))
  131.      (element-classes (get class-name 'element-classes))
  132.      (domain-element (cond ((and element-classes
  133.                      (null (rest element-classes)))
  134.                 (first element-classes))
  135.                    (t (cons 'or element-classes))))
  136.     list)
  137.     (labels ((canonicalize-class (name)
  138.            (cond ((eql name 'self) class-name)
  139.              ((atom name) name)
  140.              ((equal name '(element self))
  141.               domain-element)
  142.              (t (mapcar #'canonicalize-class name)))))
  143.       
  144.       (unless fun
  145.     (setq fun (lambda (form)
  146.             (push (cons (first form)
  147.                 (mapcar #'canonicalize-class (second form)))
  148.             list))))
  149.     (with-slots (operation-table) d
  150.       (maphash (lambda (key value)
  151.          (declare (ignore key))
  152.          (%funcall fun value))
  153.            operation-table))
  154.     list)))
  155.  
  156. #+PCL
  157. (defmethod check-domain ((d domain))
  158.   (required-operations d
  159.     (lambda (form)
  160.       (let ((operation (first form))
  161.         (args (rest form))) 
  162.     (map-over-arglist-combinations (class-name (class-of d)) args
  163.       (lambda (arg-names) 
  164.         (let ((args (loop for type in arg-names
  165.                   collect (find-class type nil))))
  166.           (loop for method in (pcl::generic-function-methods
  167.                    (symbol-function operation))
  168.             do (when (equal args
  169.                     (pcl::method-type-specifiers method))
  170.                  (return t))
  171.                finally (format t "No method for ~S~%"
  172.                        (cons operation arg-names))))))))))
  173.  
  174. (defun map-over-arglist-combinations (self arglist fun)
  175.   (labels ((recur (arglist types) 
  176.          (cond ((null arglist)
  177.             (%funcall fun (reverse types)))
  178.            ((atom (first arglist))
  179.             (recur (rest arglist) (cons (first arglist) types)))
  180.            ((eql (first (first arglist)) 'or)
  181.             (loop for type in (rest (first arglist))
  182.               do (recur (cons type (rest arglist)) types)))
  183.            ((eql (first (first arglist)) 'element)
  184.             (loop for type in (get self 'element-classes)
  185.               do (recur (cons type (rest arglist)) types)))
  186.            (t (error "Don't understand arglist entry: ~S"
  187.                  (first arglist))))))
  188.     (recur (first arglist) ())))  
  189.  
  190. ;; Domain creators
  191.  
  192. (defvar *domains* ()
  193.   "List of domains currently in use")
  194.  
  195. (defvar *morphisms* ()
  196.   "A list of the morphisms currently in use.")
  197.  
  198. (defvar *lisp-numbers* ()
  199.   "The (unique) domain for lisp numbers")
  200.  
  201. (defun reset-domains ()
  202.   (unless *lisp-numbers*
  203.     (setq *lisp-numbers* (make-instance 'lisp-numbers)))
  204.   (setq *domains* (list *lisp-numbers*))
  205.   (setq *morphisms* nil))
  206.  
  207. (defmacro add-domain (predicate &body body)
  208.   `(add-domain-internal ,predicate (lambda () ,@body)))
  209.  
  210. (defun add-domain-internal (predicate body)
  211.   (let ((domain (find nil *domains* :test (lambda (a b) 
  212.                         (declare (ignore a))
  213.                         (%funcall predicate b)))))
  214.      (when (null domain)
  215.        (setq domain (%funcall body))
  216.        (push domain *domains*))
  217.      domain))
  218.  
  219. (defun false (&rest args)
  220.   (declare (ignore args))
  221.   nil)
  222.  
  223. (defun true (&rest args)
  224.   (declare (ignore args))
  225.   t)
  226.  
  227. ;; Use this macro to define domain creators.
  228. (defmacro define-domain-creator (name args creator &key predicate body)
  229.   (labels ((parse-args (args)
  230.          (cond ((null args)
  231.             args)
  232.            ((member (first args) '(&optional &key))
  233.             (parse-args (rest args)))
  234.            ((eql (first args) '&rest)
  235.             (error "Can't handle &rest args here"))
  236.            ((atom (first args))
  237.             (cons (first args) (parse-args (rest args))))
  238.            (t (cons (first (first args))
  239.                 (parse-args (rest args)))))))
  240.     (let ((internal-fun (intern (format nil "MAKE-~A*" name)))
  241.       (true-args (parse-args args)))
  242.       `(progn
  243.      (defmethod ,internal-fun ,args ,creator)
  244.      (defmethod ,(intern (format nil "MAKE-~A" name)) ,args
  245.        (add-domain #'false (,internal-fun ,@true-args)))
  246.      ,@(when predicate
  247.          `((defmethod ,(intern (format nil "GET-~A" name)) ,args
  248.          (add-domain #',predicate (,internal-fun ,@true-args)))))
  249.      ,@(when body
  250.          `((defmethod ,(intern (format nil "GET-~A" name)) ,args
  251.          ,body)))))))
  252.  
  253. (defmacro with-new-weyl-context ((plist) &body body)
  254.   `(let ((*domains* nil)
  255.      (*morphisms* nil)
  256.      (*allow-coercions*
  257.       ,(or (getf plist :allow-coercions) '*allow-coercions*)))
  258.      ,@body))  
  259.  
  260. ;; All elements of a domain should include this class
  261.  
  262. (defclass domain-element ()
  263.   ((domain :initarg :domain
  264.        :reader domain-element-domain)))
  265.  
  266. (defmacro define-domain-element-classes (domain &body element-classes)
  267.   `(progn
  268.      ,@(loop for element-class in element-classes
  269.          collect
  270.          `(cond ((eql (get ',element-class 'domain-class) ',domain))
  271.                 (t
  272.              (when (get ',element-class 'domain-class)
  273.                (format t "WARNING: Reset domain-class of ~S~%"
  274.                    ',element-class))
  275.              (setf (get ',element-class 'domain-class) ',domain))))
  276.     (setf (get ',domain 'element-classes) ',element-classes)))
  277.  
  278. (defmethod domain-element-classes ((domain domain))
  279.   (get (class-name (class-of domain)) 'element-classes))
  280.  
  281. ;; This is so that you can pretty print objects in lucid.  It appears,
  282. ;; that you are not supposed to use PRINC inside these methods.
  283. #+Lucid
  284. (defmethod print-object :around ((object domain-element) stream)
  285.   (let ((*print-pretty* nil))
  286.     (call-next-method object stream)))
  287.  
  288. (defmethod domain-of ((element domain-element))
  289.   (domain-element-domain element))
  290.  
  291. (defgeneric coerce (elt domain))
  292. (defgeneric coercible? (elt domain))
  293.  
  294. (defmacro defmethod-binary (op domain (x y) &body body)
  295.   `(defmethod ,op ((,x ,domain) (,y ,domain))
  296.      (let ((domain (domain-of ,x)))
  297.        (cond ((eql domain (domain-of ,y))
  298.           ,@body)
  299.          (t (error "Binary operation of two elements of different~
  300.                 domains: (~S, ~S)"
  301.                ,x ,y))))))
  302.  
  303.  
  304. ;; These are often of use when defining generic operations for domains.
  305.  
  306. (defvar *domain* ()
  307.   "Within the context of an operation, the current domain")
  308.  
  309. (defmacro bind-domain-context (domain &body body)
  310.   `(%bind-dynamic-domain-context ,domain 
  311.       (lambda ()
  312.     #+Genera (declare (sys:downward-function))
  313.     ,@body)))
  314.  
  315. (defmethod %bind-dynamic-domain-context ((domain domain) function)
  316.   (let ((*domain* domain))
  317.     (%funcall function)))
  318.